# GENERIC method definitions - GAME
setGeneric("play", function(object, ...) standardGeneric("play"))
setGeneric("repeatPlay", function(object, ...) standardGeneric("repeatPlay"))
setGeneric("repeatPlayCorr", function(object, ...) standardGeneric("repeatPlayCorr"))
setGeneric("reportPayoffs", function(object, ...) standardGeneric("reportPayoffs"))
setGeneric("updatePlayers", function(object, ...) standardGeneric("updatePlayers"))
setGeneric("getOutcomeNumber", function(object, ...) standardGeneric("getOutcomeNumber"))


# GENERIC method definitions - AGENT
setGeneric("getAction", function(object, ...) standardGeneric("getAction"))
setGeneric("getRelevantPayoffs", function(object, payoffs, ...) standardGeneric("getRelevantPayoffs"))
setGeneric("setAspiration", function(object, ...) standardGeneric("setAspiration"))
setGeneric("setPropensity", function(object, ...) standardGeneric("setPropensity"))

# UTILITY functions to add / drop players from a game
attachPlayer <- function(game, player, id) {
	if (id <= length(game@players)){
		player@id <- as.integer(id)
		game@players[[id]] <- player
		#cat(paste("Player",id,"added successfully.","\n",sep=" "))
	}
	return(game)
}

dropPlayers <- function(game) {
	for (j in 1:length(game@players)) {
		game@players[[j]] <- NULL
	}
	return(game)
}

# CLASS Game - basic class that other game types extend
setClass("Game", representation(players="list", lastPayoffs="numeric", lastActions="integer"))

setMethod("initialize", "Game", function(.Object, ...) {
	.Object <- callNextMethod(.Object, ...)
	nPlayers <- length(.Object@players)
	.Object@lastPayoffs <- vector(mode="numeric", length=nPlayers)
	.Object@lastActions <- vector(mode="integer", length=nPlayers)
	return(.Object)
})

setMethod("updatePlayers", "Game", function(object) {
	for (i in 1:length(object@players)) {
		object@players[[i]] <- getRelevantPayoffs(object@players[[i]], object@lastPayoffs)

		object@players[[i]] <- setPropensity(object@players[[i]])
		object@players[[i]] <- setAspiration(object@players[[i]])
	}
	return(object)	
})

# CLASS normalGame - represent payoffs by matrix of dimension (players * actions) for every player
setClass("normalGame",representation(payoffs="list",  nOutcomes="numeric"), contains="Game")

setMethod("initialize", "normalGame", function(.Object, payoffs, ...) {
	.Object <- callNextMethod(.Object, ...)
	.Object@payoffs <- payoffs
	.Object@nOutcomes <- prod(dim(.Object@payoffs[[1]]))
    .Object
  })

setMethod("play", "normalGame", function(object) {
	# get all actions from players
	action <- vector(mode="integer", length=length(object@players))

	for (i in 1:length(object@players)) {
		action[i] <- getAction(object@players[[i]])
		object@players[[i]]@lastAction <- as.integer(action[i])
	}
	# plug into payoff matrices
	payoff <- vector(mode="numeric", length=length(object@players))
	for (i in 1:length(payoff)) {
		payoffMatrixI <- object@payoffs[[i]]
		payoff[i] <- payoffMatrixI[matrix(data=action, nrow=1, ncol=length(action))]
	}
	object@lastPayoffs <- payoff
	object@lastActions <- action

	# report payoffs to players, update their aspirations, update action propensities
	object <- updatePlayers(object)
	return(object)
})

setMethod("getOutcomeNumber", "normalGame", function(object) {
	actions <- object@lastActions
	cells <- array(data=1:object@nOutcomes, dim=dim(object@payoffs[[1]]))
	outcomeNumber <- cells[matrix(data=actions, nrow=1, ncol=length(actions))]
})
	
setMethod("repeatPlay","normalGame", function(object, reps) {
	#cat("Playing Round: ")
	outcomeVec <- vector(mode="integer", length=reps)
	for (i in 1:reps) {
			#cat(paste(i,"...",sep=""))
			object <- play(object)
			outcomeVec[i] <- as.integer(getOutcomeNumber(object))
		}
	return(outcomeVec)
})



# CLASS publicGoodGame - simplified interface for multiplayer games where only number of players cooperating matters
setClass("publicGoodGame", representation(payoffs="numeric", cooperators="integer"), contains="Game")

setMethod("initialize", "publicGoodGame", function(.Object, payoffs, ...) {
	.Object <- callNextMethod(.Object, ...)
	.Object@payoffs <- payoffs
	.Object@cooperators <- as.integer(1:length(.Object@players))
    .Object
  })

setMethod("play", "publicGoodGame", function(object) {
	# get all actions from players
	action <- vector(mode="integer", length=length(object@players))

	for (i in 1:length(object@players)) {
		action[i] <- getAction(object@players[[i]])
		object@players[[i]]@lastAction <- as.integer(action[i])
	}
	# compute payoffs: everybody gets the payoff from the cooperators, minus a cost if they personally cooperated
	payoff <- vector(mode="numeric", length=length(object@players))
	for (i in 1:length(payoff)) {
		payoff[i] <- object@payoffs[1] * sum(action) + object@payoffs[2] * as.integer(action[i] == 1)
	}
	object@lastPayoffs <- payoff
	object@lastActions <- action
	object@cooperators <- as.integer(action == 1)

	# report payoffs to players, update their aspirations, update action propensities
	object <- updatePlayers(object)
	return(object)
})

setMethod("repeatPlay","publicGoodGame", function(object, reps) {
	#cat("Playing Round: ")
	cooperatorMatrix <- matrix(data=0, ncol=length(object@players), nrow=reps)
	for (i in 1:reps) {
			#cat(paste(i,"...",sep=""))
			object <- play(object)
			cooperatorMatrix[i,] <- object@cooperators
		}
	cooperatorVec <- apply(cooperatorMatrix, MARGIN=2, FUN=mean)
	return(cooperatorVec)
})
	
setMethod("repeatPlayCorr", "publicGoodGame", function(object, reps) {
	corrMatrix <- diag(x=reps, ncol=length(object@players), nrow=length(object@players))
	for (i in 1:reps) {
		object <- play(object)
		for (j in 1:(length(object@players)-1)) {
			for (k in (j+1):length(object@players)) {
				corrMatrix[j,k] <- corrMatrix[j,k] + as.integer(object@lastActions[j] == object@lastActions[k]) - as.integer(object@lastActions[j] != object@lastActions[k])
			}
		}
	}
	corrMatrix <- corrMatrix / reps
	return(corrMatrix)
})
		
# CLASS agent

setClass("Agent", representation(id="integer", nActions="integer", propensity="numeric", lastAction="integer", lastPayoff="numeric", trembleProb="numeric"))

setMethod("initialize", "Agent", function(.Object, ...) {
    .Object <- callNextMethod(.Object, ...)
	
	if(is.null(.Object@trembleProb)) .Object@trembleProb <- 0
	.Object@propensity <- rep(1/.Object@nActions, times=.Object@nActions) # neutral start
	.Object@lastAction <- as.integer(1)
	.Object@lastPayoff <- 0
    .Object
 })

setMethod("getRelevantPayoffs", "Agent", function(object, payoffs) {
	object@lastPayoff <- payoffs[object@id]
	return(object)
})

setMethod("getAction", "Agent", function(object) {
	x <- runif(1)
	action <- as.integer(1)
	for(j in 1:(length(object@propensity)-1)) {
		if (x >= sum(object@propensity[1:j])) action <- action + 1
	}
	as.integer(action)
})

#setMethod("getAction", "Agent", function(object) {
#	x <- runif(1)
#	action <- as.integer(1)
#	for(j in 1:(length(object@propensity)-1)) {
#		if (x >= sum(object@propensity[1:j])) action <- action + 1
#		}
#	if (object@trembleProb > 0){
#		tremble <- runif(1)
#		if(tremble < object@trembleProb) {
#			action <- sample.int(object@nActions, size=1)
#		}
#	}
#	as.integer(action)
#})


# CLASS abarAgent - implements general form of aspiration based adjustment rules
setClass("abarAgent", representation(aspiration="numeric", prevAspWgt="numeric",propUpdateFunction="function",extraParms="list"), contains="Agent")
setMethod("initialize", "abarAgent", function(.Object, ...) {
	.Object <- callNextMethod(.Object, ...)
})
setValidity("abarAgent", function(object) {
	object@prevAspWgt <= 1 && object@prevAspWgt >= 0
})

setMethod("setAspiration", "abarAgent", function(object) {
  # agent only cares about own payoff
  
  # inertia for aspirations
  rnd <- runif(1)
  if (rnd > object@extraParms$aspInertiaProb) {
    object@aspiration <- object@prevAspWgt * object@aspiration + (1 - object@prevAspWgt) * object@lastPayoff
  }
  
	return(object)
})

setMethod("setPropensity", "abarAgent", function(object) {
  # inertia for propensities
  x <- abs(object@lastPayoff - object@aspiration)
  propInertiaProb <- object@extraParms$propInertiaFct(x)
  
  rnd <- runif(1)
  if (rnd > propInertiaProb) {
    if(object@lastPayoff >= object@aspiration){
      object@propensity <- object@propUpdateFunction(object, success=TRUE)
    } else {
      object@propensity <- object@propUpdateFunction(object, success=FALSE)
    }
  }
	
	rnd <- runif(1)
	if (rnd < object@trembleProb){
		object@propensity <- tremble(object@propensity)
	}
	return(object)
})

# Tremble function - modifies propensity vector when random draw indicates tremble
# in this implementation, draw from mvt normal density (of dim nActions - 1)
tremble <- function(propensity) {
	sigma = 0.01
	nActions <- length(propensity)
	basis <- do.call("cbind", getBasis(nActions))
	rnddraw <- matrix(data=rnorm((nActions-1), mean=0, sd=sigma), nrow=(nActions-1), ncol=1)
	newpropensity <- as.numeric(propensity + basis %*% rnddraw)
	if(!all(pmin(pmax(newpropensity, 1e-09),1-1e-09) == newpropensity)) {
		# ensure that we are still on the strictly positive unit simplex
		# accomplish this by just tossing and redrawing, inefficient but shouldn't be too bad most of the time
		newpropensity <- tremble(propensity)
	}
	return(newpropensity)
}

getBasis <- function(n){
	#returns remaining n-1 orthonormal basis vectors, taking the first to be (1,1,1,...,1)	
	eye <- diag(n)
	basis <- vector(mode="list", n)
	basis[[1]] <- rep(1, n)
	for (i in 2:n) {
		vI <- as.vector(eye[i,])
		basis[[i]] <- vI
		for (j in 1:(i-1)){
			basis[[i]] <- basis[[i]] - (sum(vI * basis[[j]]) / sum(basis[[j]]^2)) * basis[[j]]
		}
		norm <- sqrt(sum(basis[[i]]^2))
		basis[[i]] <- basis[[i]] / norm
	}
	
	basis[[1]] <- NULL
	return(basis)
}

# Propensity update functions - instantiate the abarAgent class with one of these to use
# various ABAR heuristics
# note that different functions will expect different stuff to be in the "extraParms" slot
# of the abarAgent object - be sure to fill these appropriately!

# FUNCTION propUpdateSatisfice - implements satisficing heuristic
propUpdateSatisfice <- function(object, success) {
	lastAction <- object@lastAction
	prop <- object@propensity
	nActions <- length(prop)
	
	if(success) {
		if (lastAction > 1) prop[1:(lastAction - 1)] <- 0
		prop[lastAction] <- 1
		if (lastAction < nActions) prop[(lastAction + 1):nActions] <- 0
	} else {
		x <- abs(object@lastPayoff - object@aspiration)
		swProb <- object@extraParms$switchFunction(x)
		if (lastAction > 1) prop[1:(lastAction - 1)] <- (swProb / (nActions-1))
		prop[lastAction] <- 1 - swProb
		if (lastAction < nActions) prop[(lastAction + 1):nActions] <- (swProb / (nActions-1))
	}
	return(prop)
}

# FUNCTION propUpdateBM - implements bush-mosteller heuristic
propUpdateBM <- function(object, success) {
	lastAction <- object@lastAction
	prop <- object@propensity
	x <- abs(object@lastPayoff - object@aspiration)
	alpha <- object@extraParms$alphaFunction(x)
	nActions <- length(prop)
	
	if(success) {
		if (lastAction > 1) prop[1:(lastAction - 1)] <- prop[1:(lastAction - 1)] - (alpha * (1 - prop[lastAction]) / (nActions - 1))
		if (lastAction < nActions) prop[(lastAction + 1):nActions] <- prop[(lastAction + 1):nActions] - (alpha * (1 - prop[lastAction]) / (nActions - 1))
		prop[lastAction] <- prop[lastAction] + alpha * (1 - prop[lastAction]) 
		
	} else {
		if (lastAction > 1) prop[1:(lastAction - 1)] <- prop[1:(lastAction - 1)] + (alpha * prop[lastAction] / (nActions-1))
		if (lastAction < nActions) prop[(lastAction + 1):nActions] <- prop[(lastAction + 1):nActions] + (alpha * prop[lastAction] / (nActions-1))
		prop[lastAction] <- prop[lastAction] * (1 - alpha)
		
	}
	return(prop)
}

# CLASS socialAgent - inherits from abarAgent, implements reference-group-based aspiration adjustment 

setClass("socialAgent", representation(refGrp="integer", refGrpLastPayoff="numeric", refWgt="numeric"), contains="abarAgent")	
setMethod("initialize", "socialAgent", function(.Object, ...) {
    	.Object <- callNextMethod(.Object, ...)
  })
setValidity("socialAgent", function(object) {
	 object@refWgt + object@prevAspWgt <= 1
})

setMethod("setAspiration", "socialAgent", function(object) {
	# consider the payoffs of the reference group also
  
  # inertia for aspirations
  rnd <- runif(1)
  if (rnd > object@extraParms$aspInertiaProb) {
    object@aspiration <- object@prevAspWgt * object@aspiration + object@refWgt * object@refGrpLastPayoff + (1 - object@prevAspWgt - object@refWgt) * object@lastPayoff
  }
	
	return(object)
})

setMethod("getRelevantPayoffs", "socialAgent", function(object, payoffs) {
	object@lastPayoff <- payoffs[object@id]
	object@refGrpLastPayoff <- mean(payoffs[object@refGrp])
	return(object)
})
	
